home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / win-os2.swg / 0027_Set WINDOWS Wallpaper.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-02-15  |  3.8 KB  |  168 lines
  1. Program Paper;
  2.  
  3. {$R-,I-,S-,L-,D-,G+}
  4.  
  5. Uses
  6.   WinTypes,WinProcs,WObjects,Strings;
  7.  
  8. { Declare undocumented Windows API call }
  9.  
  10. Procedure SetDeskWallpaper(Name : PChar);
  11.   Far; External 'USER' Index 285;
  12.  
  13. Var
  14.   hPal : HPalette;
  15.  
  16. {---------------------------------------------------}
  17.  
  18. { --- App/Win Object declarations --- }
  19.  
  20. Type
  21.   TPaperApp = Object(TApplication)
  22.                 Procedure InitMainWindow; Virtual;
  23.               End;
  24.  
  25.   PPaperWindow = ^PaperWindow;
  26.   PaperWindow = Object(TWindow)
  27.                   Procedure SetupWindow;
  28.                     Virtual;
  29.  
  30.                   Procedure WMQueryNewPalette(Var Msg : TMessage);
  31.                     Virtual wm_QueryNewPalette;
  32.  
  33.                   Procedure WMPaletteChanged(Var Msg : TMessage);
  34.                     Virtual wm_PaletteChanged;
  35.                 End;
  36.  
  37. {---------------------------------------------------}
  38.  
  39. { --- App Methods --- }
  40.  
  41. Procedure TPaperApp.InitMainWindow;
  42.  
  43. Begin
  44.   If hPrevInst = 0
  45.     Then MainWindow := New(PPaperWindow,Init(nil,'Paper'))
  46.     Else Halt(0);
  47. End {InitMainWindow};
  48.  
  49. { --- Window Methods --- }
  50.  
  51. {---------------------------------------------------}
  52.  
  53. Procedure PaperWindow.SetupWindow;
  54.  
  55. Var
  56.   PaperStr : Array [0..80] Of Char;
  57.   FName : String[80];
  58.   DC : HDC;
  59.   LogPal : TLogPalette;
  60.   hOldPal : HPalette;
  61.  
  62. Begin
  63.   { Retreive filename - if none: we just fixup the palette }
  64.   FName := ParamStr(1);
  65.  
  66.   If FName <> ''
  67.     Then Begin
  68.            { Add .BMP to filename, if necess. }
  69.            If Pos('.',FName) = 0
  70.              Then FName := FName + '.bmp';
  71.  
  72.            { Put string in "C" style }
  73.            StrPCopy(PaperStr,FName);
  74.  
  75.            { Make sure we keep WIN.INI apprised of our changes }
  76.            WriteProfileString('Desktop','Wallpaper',PaperStr);
  77.  
  78.            { Set the wallpaper }
  79.            SetDeskWallpaper(PaperStr);   { Undoc'd win call }
  80.          End;
  81.  
  82.   { Invalidate the screen, even if we don't load a new wallpaper - if
  83.     we don't do this, the "transparent" areas of icons will be fratzed up }
  84.   InvalidateRect(0,Nil,False);
  85.  
  86.   { Create a small palette to fix the fact that loading the wallpaper
  87.     doesn't realize the palette }
  88.  
  89.   LogPal.palVersion := $0300;
  90.   LogPal.palNumEntries := 1;
  91.   LogPal.palPalEntry[0].peRed := 0;
  92.   LogPal.palPalEntry[0].peGreen := 0;
  93.   LogPal.palPalEntry[0].peBlue := 0;
  94.   LogPal.palPalEntry[0].peFlags := 0;
  95.  
  96.   { Get a DC and realize our palette }
  97.   DC := GetDC(HWindow);
  98.  
  99.   hPal := CreatePalette(LogPal);
  100.   hOldPal := SelectPalette(DC,hPal,False);
  101.  
  102.   RealizePalette(DC);
  103.  
  104.   { Close up our palette stuff }
  105.   SelectPalette(DC,hOldPal,False);
  106.  
  107.   DeleteObject(hPal);
  108.   ReleaseDC(HWindow,DC);
  109.  
  110.   { Close ourselves automatically }
  111.   PostMessage(HWindow,wm_Close,0,0);
  112.  
  113. End {SetupWindow};
  114.  
  115. {---------------------------------------------------}
  116.  
  117. Procedure PaperWindow.WMQueryNewPalette(Var Msg : TMessage);
  118.  
  119. Var
  120.   ahDC : HDC;
  121.  
  122. Begin
  123.   ahDC := GetDC(HWindow);
  124.   SelectPalette(ahDC,hPal,False);
  125.  
  126.   If (RealizePalette(ahDC) > 0)
  127.     Then Begin
  128.            ReleaseDC(HWindow,ahDC);
  129.            InvalidateRect(HWindow,Nil,False)
  130.          End
  131.     Else ReleaseDC(HWindow,ahDC);
  132. End {WMQueryNewPalette};
  133.  
  134. {---------------------------------------------------}
  135.  
  136. Procedure PaperWindow.WMPaletteChanged(Var Msg : TMessage);
  137.  
  138. Var
  139.   ahDC : HDC;
  140.  
  141. Begin
  142.   If Msg.wParam <> HWindow
  143.     Then Begin
  144.            ahDC := GetDC(HWindow);
  145.            SelectPalette(ahDC,hPal,False);
  146.  
  147.            If (RealizePalette(ahDC) > 0)
  148.              Then InvalidateRect(HWindow,nil,False);
  149.  
  150.            ReleaseDC(HWindow,ahDC);
  151.          End;
  152. End {WMPaletteChanged};
  153.  
  154. {---------------------------------------------------}
  155.  
  156. { --- Main --- }
  157.  
  158. Var
  159.   PaperApp : TPaperApp;
  160.  
  161. Begin
  162.   CmdShow := sw_Minimize;
  163.  
  164.   PaperApp.Init('Paper');
  165.   PaperApp.Run;
  166.   PaperApp.Done;
  167. End.
  168.